package Object::Info;

=begin
object {
	class     => 'MyObject',
	fields    => [ a b c ]
	public    => [ a ],
	private   => [ b ],
	protected => [ c ],
	field => {
		a => {
			defined_by     => 'MyObject1',
			inherited_from => 'MyObject2',
			type      => 1,
		}
	}
}

=cut
use strict;
use Carp ();
our @CARP_NOT = qw(Object::Info Object Object::_);
use Object::Const;
use Object::Global ();

our %_; # Cache
our %OPTIONS;*OPTIONS = \%Object::Global::OPTIONS;

our $defined_by = 'by';
our $inherited_from = 'from';

sub get {
	my $self = shift;
	my $cls = shift;
	$cls = ref $cls if ref $cls;
	return $_{$cls} if exists $_{$cls};
	warn "$cls have no definition via use Object ...\n";
	return;
}

sub collect {
	no strict 'refs';
	my $self = shift;
	my $cls = shift;
	my @i;
	for (grep { !/^Object$/} @{ $cls.'::ISA' }) {
		if ( exists $_{$_} ) {
			push @i,$_{$_};
		}else{
			#warn "[Object]: no info for $_ [$cls]\n";
			push @i,$self->get($_);
		}
	}
	return @i;
}

sub carp {
	my $self = shift;
	( my $m = shift ) =~ s/\n+$//;
	my $cls = ref $self ? $self->{class} : $self;
	Carp::carp("$cls: ".(@_ ? sprintf($m,@_) : $m));
}

sub croak {
	my $self = shift;
	( my $m = shift ) =~ s/\n+$//;
	my $cls = ref $self ? $self->{class} : $self;
	Carp::croak("$cls: ".(@_ ? sprintf($m,@_) : $m));
}

sub info {
	my $self = shift;
	( my $m = shift ) =~ s/\n+$//;
	#my $prefix = '';
	my $prefix = $1 if $m =~ s/^(\s*)//;
	warn $prefix."$self->{class}: ".(@_ ? sprintf($m,@_) : $m)."\n";
}

sub extend {
	my ($self,$type,$list,$from,$refs,$opts) = @_;
	$opts ||= {};
	$self->{options}->{$_} = $opts->{$_} for keys %$opts;
	for my $f ( @$list ) {
		#$self->info("\t$f ($T{$type}:@{[ $from ]})\n");
		my $provider = $from ? $refs->{$f} || {
			$defined_by => $from,
		} : undef;
		if (exists $self->{field}->{$f}) {
			my $ct = $self->{field}->{$f};
			my $by = ($self->{class} eq $ct->{$defined_by} ? "defined" : "already inherited from class $ct->{$inherited_from}");
			my $found = $provider ? "found in ". ( $provider->{$inherited_from} || $provider->{$defined_by} ) : "redefined";
			if ($ct->{type} eq $type) { # same type
				if ($provider and $provider->{$defined_by} ne $ct->{$defined_by}) { # defined by different classes
					$self->carp( "$type field $f is $by, but $found" );
				}
				elsif(!$provider and $ct->{$defined_by} ne $self->{class}){
					$self->carp( "$type field $f is $by, but $found" );
				}
			}
			else{ # another type
				$self->croak(
					"$self->{class}: $type field $f already $by with type ($ct->{type}) but $found with type $type"
				);
			}
		}else{
			push @{ $self->{$type} },$f;
			push @{ $self->{fields} },$f;
			$self->{field}->{$f} = {
				type => $type,
				
				$defined_by     => $provider ? $provider->{$defined_by} : $self->{class},
				$from ? ( $inherited_from =>  $from ) : (),
			};
		}
	}
	
}

sub new {
	my ($pkg,$cls,$defs,$opts) = @_;
	return $_{$cls} if exists $_{$cls};
	my @s = $pkg->collect( $cls );
	my $self = bless {
		class     => $cls,
		base      => [ map { $_->{class} } @s ],
		isa       => do{ no strict 'refs'; \@{ $cls.'::ISA' } },
		public    => [],
		private   => [],
		protected => [],
		fields    => [],
		field     => {},
		options   => {},
	},$pkg;
	$_{$cls} = $self;
	if ($opts->{abstract}) {
		$self->{options}{abstract} = 1;
		return $self;
	}
	my $options = {};
	{
		for my $opt_key ( keys %$opts ) {
			my $conf = $OPTIONS{$opt_key} or $self->croak("Unsupported option: $opt_key");
			my $name = $conf->{''};
			$self->carp("$opt_key redefined") if exists $options->{$name};
			my $opt = eval { Object::_::option(delete $opts->{$opt_key}) };
			$self->croak("$$@ as $name option") if ref $@;
			my $ropt = {};
			for my $key (keys %$opt) {
				$self->croak("Unknown $name option: $key") unless $conf->{$key};
				for(@{$conf->{$key}}){
					$self->carp("$_ redefined in $name $key") if exists $ropt->{$_};
					$ropt->{$_} = $opt->{$key};
				};
			}
			$options->{$name} = $ropt;
		}
		
	}
	for my $base (@s) {
		for ($base->fields) {
			my $f = $base->{field}->{$_};
			next if $f->{type} eq 'private';
			$self->extend($f->{type} => [ $_ ], $base->{class}, $base->{field},$options);
		}
	}
	for my $type (@TYPES) {
		$self->extend($type => $defs->{$type},undef,undef,$options);
	}
	return $self;
}

sub f {
	my $self = shift;
	return $self->{field}->{shift()};
}

sub __get_list {
	my $self = shift;
	my $attr = shift;
	#warn "WA OI:$attr <".wantarray.">\n";
	return
		wantarray
			? @{ $self->{$attr} }
			: $self->{$attr}
}

sub fields    { shift->__get_list('fields') }
sub public    { shift->__get_list('public') }
sub private   { shift->__get_list('private') }
sub protected { shift->__get_list('protected') }

sub import {
	my $pkg= shift;
	my @list = @_ or return;
	my $clr = caller;
	$TYPE{$pkg} or Carp::croak("Unknown extension $pkg for Object. $pkg cant be called with arguments");
	Object::Info->get($clr)->extend( $TYPE{$pkg} =>[ @list ] );
	return;
}

sub by_str {
	my $self = shift;
	my $f = shift;
	my $ref = $self->{field}->{$f};
	return ( $ref->{$defined_by} ne $self->{class} ? $ref->{$defined_by}.':' : '' ).$f;
}

sub to_string {
	my $self = shift;
	sprintf "%s:
	type      : %s init(%s)
	isa       : %s
	base      : %s
	all       : %s
	public    : %s
	private   : %s
	protected : %s\n",
		$self->{class},
		$self->implementation,
		$self->initialization,
		join(', ',@{ $self->{isa} }),
		join(', ',@{ $self->{base} }),
		join(', ',$self->fields),
		join(', ',map$self->by_str($_),$self->public),
		join(', ',map$self->by_str($_),$self->private),
		join(', ',map$self->by_str($_),$self->protected),
	;
}

sub check {
	my $self = shift;
	my $option = shift;
	return exists $self->{options}{check}{$option}
		? $self->{options}{check}{$option}
		: $Object::Global::_{check}{$option};
}
sub opt {
	my $self = shift;
	my $type = shift;
	my $option = shift;
	return exists $self->{options}{$type}{$option}
		? $self->{options}{$type}{$option}
		: $Object::Global::_{$type}{$option};
}

sub implementation {
	my $self = shift;
	( exists $self->{options}{check}{fields} ? $self->{options}{check}{fields} : $Object::Global::_{check}{fields} )
	? 'tie' : 'hash';
}

sub initialization {
	my $self = shift;
	( exists $self->{options}{check}{init} ? $self->{options}{check}{init} : $Object::Global::_{check}{init} )
	? 'strict' : 'soft';
}

1;
